home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 21 / Cream of the Crop 21 (Terry Blount) (October 1996).iso / program / tspa3555.zip / TSUNTJ.TST < prev    next >
Text File  |  1995-03-02  |  3KB  |  139 lines
  1. {$M 16384,0,80000}
  2. (* This is a test program for the TSUNTJ.TPU unit
  3.    Note the heap needed because of the COPYFILE procedure *)
  4.  
  5. uses TSUNTJ,
  6.      TSUNTB;  { for the HEXFN in procedure TEST4 }
  7.  
  8. procedure LOGO;
  9. begin
  10.   writeln;
  11.   writeln ('TSUNTJ unit test by Prof. Timo Salmi, 2-Mar-95');
  12.   writeln ('University of Vaasa, Finland, ts@uwasa.fi');
  13. {$IFDEF VER40}
  14.   writeln ('TP version 4.0');
  15. {$ENDIF}
  16. {$IFDEF VER50}
  17.   writeln ('TP version 5.0');
  18. {$ENDIF}
  19. {$IFDEF VER55}
  20.   writeln ('TP version 5.5');
  21. {$ENDIF}
  22. {$IFDEF VER60}
  23.   writeln ('TP version 6.0');
  24. {$ENDIF}
  25. {$IFDEF VER70}
  26.   writeln ('TP version 7.0');
  27. {$ENDIF}
  28.   writeln;
  29. end;  (* logo *)
  30.  
  31. (* Testing copy *)
  32. procedure TEST1;
  33. var file1, file2 : string;
  34.     status       : byte;
  35. begin
  36.   file1 := 'c:\command.com';
  37.   file2 := 'r:\command.com';
  38.   COPYFILE (file1, file2, status);
  39.   if status = 0 then
  40.      writeln (file1, ' copied to ', file2)
  41.    else
  42.      begin
  43.        writeln ('Error in copying ', file1, ' to ', file2);
  44.        writeln ('Status = ', status);
  45.      end;
  46. end;  (* test1 *)
  47.  
  48. (* Testing if the given name is a directory *)
  49. procedure TEST2;
  50. var name : string;
  51.     b    : boolean;
  52. begin
  53.   name := ParamStr(1);
  54.   b := ISDIRFN (name);
  55.   writeln (name, ' is a directory: ', b);
  56.   b := ISDIR2FN (name);
  57.   writeln (name, ' is a directory: ', b);
  58. end;  (* test2 *)
  59.  
  60. (* Test where the standard input comes from, and where does the standard
  61.    output go to *)
  62. procedure TEST3;
  63. var s   : string;
  64.     con : text;
  65. begin
  66.   { We must have a way to write messages to the screen irrespective of
  67.     where the standard output is directed. }
  68.   assign (con, 'con');
  69.   rewrite (con);
  70.   {}
  71.   if PIPEDIFN then
  72.     writeln (con, 'Input from redirection')
  73.     else writeln (con, 'Input not from redirection');
  74.   {}
  75.   if PIPEDOFN then
  76.     writeln (con, 'Output redirected')
  77.     else writeln (con, 'Output not redirected');
  78.   {}
  79.   if PIPEDNFN then
  80.     writeln (con, 'Output redirected to nul')
  81.     else writeln (con, 'Output not redirected to nul');
  82.   {}
  83.   close (con);
  84. end;  (* test3 *)
  85.  
  86. (* Show interrupt information *)
  87. procedure TEST4;
  88. const intn : byte = $1F;  { graphics display character table }
  89. var segm, offs : word;
  90. begin
  91.   INTRLOCA (intn, segm, offs);
  92.   writeln ('Interrupt $', HEXFN(intn), ' is located at [',
  93.             HEXFN(segm),':$', HEXFN(offs), ']');
  94.   INTRADDR (intn, segm, offs);
  95.   writeln ('Interrupt $', HEXFN(intn), ' points to mem [',
  96.             HEXFN(segm),':$', HEXFN(offs), ']');
  97. end;  (* test4 *)
  98.  
  99. (* Test whether a name refers to a directory *)
  100. procedure TEST5;
  101. const name = 'r:\cmand';
  102. var b : boolean;
  103. begin
  104.   b := ISDIR3FN(name);
  105.   writeln (name, ' is a directory is ', b);
  106. end;  (* test5 *)
  107.  
  108. (* Testing if a non-text file is open *)
  109. procedure TEST6;
  110. const name = 'R:\TMP';
  111. var f  : file;
  112. begin
  113.   Assign (f, name);
  114.   writeln ('File ', name, ' is open is ', OPENFLFN(f));
  115.   {$I-} rewrite (f); {$I+}
  116.   if IOResult <> 0 then
  117.     begin
  118.       writeln ('Failed to open ', name);
  119.       exit;
  120.     end;
  121.   writeln ('File ', name, ' is open is ', OPENFLFN(f));
  122.   close(f);
  123.   writeln ('File ', name, ' is open is ', OPENFLFN(f));
  124. end;  (* test6 *)
  125.  
  126. (* Main program *)
  127. begin
  128.   LOGO;
  129.   {      If you want test other than 2, remove the two bracket lines
  130.   TEST1;
  131.   TEST3;
  132.   TEST4;
  133.   TEST5;
  134.   TEST6;
  135.   write ('Press <═╝'); readln;
  136.   }
  137.   TEST2;
  138. end.  (* tsuntj.tst *)
  139.